
open Ast

exception Variable_non_trouvee of string * loc
exception Erreur_de_typage of string * loc
exception Main_inexistant
exception Return_mal_type

type struct_or_union =
	| Struct
	| Union

let plus_petite_relation_types t1 t2 =
	let regle1 t =
		match t with
		| Tint | Tchar | Tnull -> true
		| _ -> false
	in
	let rec egalite_types t1 t2 = 
		match (t1,t2) with
		| (Tnull,Tnull) | (Tvoid,Tvoid) | (Tint,Tint) | (Tchar,Tchar) -> true
		| (Tstruct id1, Tstruct id2) | (Tunion id1, Tunion id2) -> if (String.compare id1.node id2.node) == 0 then true else false
		| (Tpointer t1, Tpointer t2) -> egalite_types t1 t2
		| (_,_) -> false
	in
	if (regle1 t1) && (regle1 t2) then true else
	if egalite_types t1 t2 then true else
	match (t1,t2) with
		| (Tnull, Tpointer _) | (Tpointer _, Tnull) -> true
		| (Tpointer Tvoid, Tpointer _) | (Tpointer _, Tpointer Tvoid) -> true
		| _ -> false

let typer_constante constante =
	match constante with
	| Cint i -> if (i == Int32.zero) then Tnull else Tint
	| Cstring _ -> Tpointer Tchar

let rec typer_ident env_list ident =
	match env_list with
	| [] -> raise Not_found
	| a::s -> (try Hashtbl.find a ident with Not_found -> typer_ident s ident)
	
let typer_sizeof env_struct c_type loc =
	let rec typer_c_type t =
		match t with
		| Tnull | Tvoid | Tint | Tchar -> true
		| Tpointer t2 -> (typer_c_type t2)
		| Tunion id | Tstruct id -> (Hashtbl.mem env_struct id.node)
	in
	if typer_c_type c_type && not (plus_petite_relation_types Tvoid c_type) then Tint else raise (Erreur_de_typage ("sizeof",loc))

let typer_dot env_struct e ident =
	let rec trouver_ident content =
		match content with
		| [] -> raise (Erreur_de_typage (("dot : unknown ident "^ident.node), ident.loc))
		| (id,typ)::s -> if compare id ident.node == 0 then typ else trouver_ident s
	in
	match e.loc with
	| Tnull | Tvoid | Tint | Tchar | Tpointer _ -> raise (Erreur_de_typage ("dot",ident.loc))
	| Tstruct id | Tunion id -> 
		let struc = (try 
			Hashtbl.find env_struct id.node
		with Not_found -> raise (Erreur_de_typage (("Structure : "^id.node^" non trouve"),id.loc) ))in
			
		let content = snd struc in
		trouver_ident content	

let num t =
	if plus_petite_relation_types Tint t || plus_petite_relation_types Tchar t || plus_petite_relation_types Tnull t || plus_petite_relation_types (Tpointer Tvoid) t then true else false

let typer_assign e1 e2 loc =
	match (e1.loc,e2.loc) with
	| (Tint, Tpointer _) | (Tpointer _, Tint) -> e1.loc
	| (_,_) -> if plus_petite_relation_types e1.loc e2.loc then e1.loc else raise (Erreur_de_typage ("assign",loc))

let typer_unop unop e loc =
	match unop with
	| Upre_inc | Upost_inc | Upre_dec | Upost_dec -> if num e.loc then e.loc else raise (Erreur_de_typage ("unop Upost/Uprec inc/dec",loc))
	| Ustar -> (match e.loc with
		| Tpointer t -> t
		| _ -> raise (Erreur_de_typage ("unop Ustar",loc)))
	| Uamp -> Tpointer e.loc 
	| Unot -> if num e.loc then Tint else raise (Erreur_de_typage ("unop Unot",loc))
	| Uminus | Uplus ->
		if plus_petite_relation_types e.loc Tint then Tint else raise (Erreur_de_typage ("unop Uminus Uplus",loc))

let typer_binop binop e1 e2 loc =
	let typer_op () =
		if (plus_petite_relation_types e1.loc e2.loc) && (plus_petite_relation_types e1.loc Tint) then Tint else
		raise (Erreur_de_typage ("binop Bop", loc))
	in
	let typer_add add =
		try (typer_op ()) with Erreur_de_typage (s,loc) -> (
		match (e1.loc, e2.loc) with
			| (Tpointer t,_) -> if plus_petite_relation_types e2.loc Tint then e1.loc
				else raise (Erreur_de_typage (("binop Badd -> "^s),loc))
			| (_,Tpointer t) -> if add && plus_petite_relation_types e1.loc Tint then e2.loc
				else raise (Erreur_de_typage (("binop Badd -> "^s),loc))
			| (_,_) -> raise (Erreur_de_typage (("binop Badd -> "^s),loc))
	)
	in
	let typer_sub () =
		try (typer_add false) with Erreur_de_typage (s,loc) -> (
		match (e1.loc, e2.loc) with
			| (_,Tpointer t) -> if plus_petite_relation_types e1.loc e2.loc then Tint
				else raise (Erreur_de_typage (("binop Bsub -> "^s),loc))
			| (_,_) -> raise (Erreur_de_typage (("binop Bsub -> "^s),loc))
		)
	in

	match binop with
	| Beq | Bneq | Blt | Ble | Bgt | Bge ->
		(match e1.loc with
		| Tstruct _ | Tunion _ | Tvoid -> raise (Erreur_de_typage ("binop Bcomp : Struct, union or void",loc))
		| _ -> (match (e1.loc,e2.loc) with
			| (Tint, Tpointer _) | (Tpointer _, Tint) -> Tint
			| (_,_) -> if plus_petite_relation_types e1.loc e2.loc then Tint else raise (Erreur_de_typage ("binop Bcomp",loc))
			)
		)
	| Bmul | Bdiv | Bmod | Band | Bor ->
		 typer_op ()
	| Badd  ->
		typer_add true
	| Bsub ->
		typer_sub ()

let rec typer_call env_fun ident l_expr =
	let (retour,args) = 
		(try		
			Hashtbl.find env_fun ident.node
		with Not_found -> raise (Erreur_de_typage (("Function : "^ident.node^" non trouve"),ident.loc ))) in
	let verifier_typage arg expr =
		if (plus_petite_relation_types expr.loc arg) then () else raise (Erreur_de_typage ("call",ident.loc))
	in if List.length args == List.length l_expr then (
		List.iter2 verifier_typage args l_expr;
		retour)
	else raise (Erreur_de_typage ("nombre d'arguments",ident.loc))
and
typer_expr env_struct env_list env_fun e =
	match e.node with
	| Enull -> {node = Enull; loc = Tnull}
	| Econst constante -> { node = Econst constante; loc = (typer_constante constante) }
	| Eident ident -> (try let id = (typer_ident env_list ident.node) in { node = Eident ident; loc = id } with Not_found -> raise (Variable_non_trouvee (ident.node, ident.loc)))
	| Esizeof c_type -> { node = Esizeof c_type; loc = (typer_sizeof env_struct c_type e.loc) }
	| Edot (expr, ident) ->
		let e = typer_expr env_struct env_list env_fun expr in
		{ node = Edot(e,ident); loc = (typer_dot env_struct e ident)}
	| Eassign (expr1, expr2) ->
		let e1 = typer_expr env_struct env_list env_fun expr1 in
		let e2 = typer_expr env_struct env_list env_fun expr2 in
		{ node = Eassign(e1,e2); loc=typer_assign e1 e2 e.loc}
	| Eunop (unop, expr) -> let loc = e.loc in
		let e = typer_expr env_struct env_list env_fun expr in
		{ node = Eunop(unop,e); loc=typer_unop unop e loc}
	| Ebinop (binop, expr1, expr2) ->
		let e1 = typer_expr env_struct env_list env_fun expr1 in
		let e2 = typer_expr env_struct env_list env_fun expr2 in
		{ node = Ebinop(binop,e1,e2); loc=typer_binop binop e1 e2 e.loc}
	| Ecall (ident, l_expr) ->
		let rec typer_l_expr l_expr =
			match l_expr with
			| [] -> []
			| a::s -> (typer_expr env_struct env_list env_fun a)::(typer_l_expr s)
		in
		let l_expr = typer_l_expr l_expr in
		{ node = Ecall(ident,l_expr); loc=(typer_call env_fun ident l_expr) }

let typer_var_decl env_struct env_local (typ,id) =
	let rec est_bien_type t = 
		match t with
		| Tnull ->  raise (Erreur_de_typage ("Impossible de typer Tnull",id.loc))
		| Tvoid -> t
		| Tint -> t
		| Tchar -> t
		| Tstruct ident -> if (Hashtbl.mem env_struct ident.node) && fst (Hashtbl.find env_struct ident.node) == Struct then t else raise (Erreur_de_typage ("Structure " ^ ident.node ^ " unknown", id.loc))
		| Tunion ident -> if (Hashtbl.mem env_struct ident.node) && fst (Hashtbl.find env_struct ident.node) == Union then t else raise (Erreur_de_typage ("Union " ^ ident.node ^ " unknown", id.loc))
		| Tpointer c_type -> Tpointer(est_bien_type c_type)
	in
	if not (plus_petite_relation_types typ Tvoid) && not (Hashtbl.mem env_local id.node) then (Hashtbl.add env_local id.node (est_bien_type typ); (typ,id)) else  raise (Erreur_de_typage ("declaration " ^ id.node, id.loc))


let rec typer_var_decl_list env_struct env_global var_decl_list =
	match var_decl_list with
	| [] -> []
	| a::s -> let n = (typer_var_decl env_struct env_global a) in n::(typer_var_decl_list env_struct env_global s)

let rec typer_statement env_struct env_list env_fun ?typ_ret statement =
	match statement with
	| Sskip -> Sskip
	| Sexpr expr -> Sexpr(typer_expr env_struct env_list env_fun expr)

	| Sif (expr, statement1, statement2) ->
		let cond = typer_expr env_struct env_list env_fun expr in
		let s1 = {node=typer_statement env_struct env_list env_fun ?typ_ret:typ_ret statement1.node; loc=Tnull} in
		let s2 = {node=typer_statement env_struct env_list env_fun ?typ_ret:typ_ret statement2.node; loc=Tnull} in
		Sif(cond,s1,s2)

	| Swhile (expr, statement1) ->
		let cond = typer_expr env_struct env_list env_fun expr in
		let s1 = typer_statement env_struct env_list env_fun ?typ_ret:typ_ret statement1.node in
		Swhile(cond,{node=s1; loc=Tnull})

	| Sfor (statement_list1, expr, statement_list2, statement1) ->
		let sl1 = typer_statement_list env_struct env_list env_fun ?typ_ret:typ_ret statement_list1 in
		let e = typer_expr env_struct env_list env_fun expr in
		let sl2 = typer_statement_list env_struct env_list env_fun statement_list2 in
		let s1 = typer_statement env_struct env_list env_fun statement1.node in
		Sfor(sl1,e,sl2,{node=s1;loc=Tnull})

	| Sblock block -> Sblock(typer_block env_struct env_list env_fun ?typ_ret:typ_ret block)
	| Sreturn opt -> (match typ_ret with
		| None -> raise Return_mal_type
		| Some typ ->  let (ret,t) =
			match opt with
			| Some expr -> let e = typer_expr env_struct env_list env_fun expr in (Sreturn (Some (e)),e.loc)
			| None -> (Sreturn None,Tvoid)
			in (
			match (t,typ) with
			| (Tint, Tpointer _) | (Tpointer _, Tint) | (Tnull, Tpointer _) | (Tpointer _, Tnull)-> ret
			| (_,_) -> if plus_petite_relation_types t typ then ret else raise Return_mal_type
			)
		)

  
and
  
typer_statement_list env_struct env_list env_fun ?typ_ret statement_list =
	match statement_list with
	| [] -> []
	| a::s -> let node = {node=(
		match typ_ret with
		| None -> typer_statement env_struct env_list env_fun a.node
		| Some x -> typer_statement env_struct env_list env_fun ~typ_ret:x a.node
	)
	;loc=Tnull} in
	match typ_ret with
	| None -> node::(typer_statement_list env_struct env_list env_fun s)
	| Some x -> node::(typer_statement_list env_struct env_list env_fun ~typ_ret:x s)

and

typer_block env_struct env_list env_fun ?typ_ret (var_decl_list, statement_list)=
	let (sous_env_local : (string, c_type) Hashtbl.t) = Hashtbl.create 20 in
	let var_decl_list2 = typer_var_decl_list env_struct sous_env_local var_decl_list in
	let statement_list2 =
		match typ_ret with
		| None -> typer_statement_list env_struct (sous_env_local::env_list) env_fun statement_list
		| Some x -> typer_statement_list env_struct (sous_env_local::env_list) env_fun ~typ_ret:x statement_list
	in
	(var_decl_list2,statement_list2)

		
let typer_dstruct_dunion env_struct typ ident var_decl_list =
	let rec compter_pointer typ ident =
		match typ with
		| Tpointer e -> let (b,t) = compter_pointer e ident in (b, Tpointer t)
		| Tstruct id -> if (String.compare (id.node) (ident.node)) == 0 then (true, Tstruct id) else (false, Tnull)
		| _ -> (false, Tnull)
	in
	let (env_local : (string, c_type) Hashtbl.t) = Hashtbl.create 20 in
	let rec typer (typ,id) s = 
			let (typ,id) = typer_var_decl env_struct env_local (typ,id) in
			let (s1,s2) = remplir_tbl s in
			((id.node,typ)::s1, (typ,id)::s2)
	and remplir_tbl var_decl_list =
		match var_decl_list with
		| [] -> ([],[])
		| (typ,id)::s -> (match typ with
			| Tpointer e -> let (b,typ) = compter_pointer typ ident in if b then
				let (s1,s2) = remplir_tbl s in ((id.node,typ)::s1 ,(typ, id)::s2)
				else (typer (typ,id) s)
			| _ -> typer (typ,id) s)
	in
	if (Hashtbl.mem env_struct ident.node) then raise (Erreur_de_typage ("dstruct/dunion", ident.loc)) else (let (s1,s2) = remplir_tbl var_decl_list in
		Hashtbl.add env_struct ident.node (typ, s1);
		s2)

let typer_dfun env_struct env_global env_fun typev ident args block =
	let (env_local : (string, c_type) Hashtbl.t) = Hashtbl.create 20 in
	if (Hashtbl.mem env_global ident.node) or (Hashtbl.mem env_fun ident.node) then raise (Erreur_de_typage ("dfun : existe deja",ident.loc)) else begin
		let rec match_args args =
			match args with
			| [] -> []
			| a::s ->
			if not (plus_petite_relation_types Tvoid (fst a)) then let y = typer_var_decl env_struct env_local a in (fst y)::(match_args s)
			else raise (Erreur_de_typage ("dfun : argument void", ident.loc))
		in
		let args_c_type_list = match_args args in
		let typev = match typev with
			| Tnull -> raise (Erreur_de_typage ("dfun : retour incorrecte", ident.loc))
			| _ -> typev
		in
		Hashtbl.add env_fun ident.node (typev, args_c_type_list);
		let block = typer_block env_struct (env_local::[env_global]) env_fun ~typ_ret:typev block in
		Dfun(typev,ident,args,block)
	end

let typer_decl env_struct env_global env_fun decl =
	match decl with
	| Dvars(var_decl_list) -> Dvars(typer_var_decl_list env_struct env_global var_decl_list)
	| Dfun(typev,ident,args,block) -> typer_dfun env_struct env_global env_fun typev ident args block
	| Dstruct(ident,var_decl_list) -> Dstruct(ident,typer_dstruct_dunion env_struct Struct ident var_decl_list)
	| Dunion(ident,var_decl_list) -> Dstruct(ident,typer_dstruct_dunion env_struct Union ident var_decl_list)

let typer_fichier fichier =
	let (env_struct : (string, (struct_or_union * (string * c_type) list)) Hashtbl.t) = Hashtbl.create 20 in
	let (env_global : (string, c_type) Hashtbl.t) = Hashtbl.create 20 in
	let (env_fun : (string, (c_type * c_type list)) Hashtbl.t) = Hashtbl.create 20 in
	(* ajout de putchar *)
	Hashtbl.add env_fun "putchar" (Tint, [Tint]);
	(* ajout de getchar *)
	Hashtbl.add env_fun "getchar" (Tint, []);
	(* ajout de sbrk *)
	Hashtbl.add env_fun "sbrk" (Tpointer Tvoid, [Tint]);
	let rec loop fichier =
		match fichier with
		| [] -> []
		| a::s -> 
			let t1 = (typer_decl env_struct env_global env_fun a) in
			let t2 = (loop s) in
			t1::t2
	in
	let retour = loop fichier in
	(* verification du main *)
	(if Hashtbl.mem env_fun "main" then (
		let main = Hashtbl.find env_fun "main" in
		(match main with
		| (Tint, Tint::(Tpointer Tpointer Tchar)::[])
		| (Tint, []) -> ()
		| _ -> raise Main_inexistant);
	) else raise Main_inexistant);
	retour

